Alles Voor Internet / Tout Pour Internet

home *** CD-ROM | disk | FTP | other *** search

/ Alles Voor Internet / Tout Pour Internet / alles voor internet.iso / MacInternet™ / Telnet / Comet.3.0.7 Folder / ibm-host-software / FT3270.ASSEMBLE < prev next >

Wrap

Text File | 1992-09-09 | 90KB | 1,117 lines

FT3270 TITLE 'TRANSFER FILES TO/FROM A PERSONAL COMPUTER' XA 00010000 ********************************************************************* 00020000 * THIS PROGRAM IS THE USER PORTION OF THE FT3270 FILE TRANSFER * 00030000 * PROGRAMS BETWEEN CMS AND THE IBM PC & THE APPLE MACINTOSH. IT * 00040000 * INITIATES A FILE TRANSFER BY SENDING SPECIAL CHARACTERS IN THE * 00050000 * DATASTREAM WHICH ARE INTERPRETED BY BOTH TN3270 AND C19 ON THE * 00060000 * MICROS WHICH HAVE FT3270 SERVERS LINKED INTO THE MICRO COMPUTER * 00070000 * EXECUTABLE PROGRAM. * 00080000 * * 00090000 * FT3270 WORKS WITH CORNELL TN3270 ON THE MICRO COMPUTERS AS * 00100000 * WELL AS CORNELL C19 WHICH IS A SERIAL PORT EMULATOR SIMILAR TO * 00110000 * HEATH19 WHICH USES AN IBM 7171 AS A FRONT END TRANSLATOR. THE * 00120000 * 7171 IMPOSES SOME REQUIREMENTS ON THE DATASTREAM TO INFORM IT * 00130000 * THAT THE DATA IS TO PASSED TRANSPARENTLY TO THE OTHER END. THESE * 00140000 * EXTRA CHARACTERS ARE NOT STRIPPED OFF BY TELNET SO THEY SHOW UP * 00150000 * ON THE OTHER END WHEN ACCESS IS VIA TN3270. * 00160000 * * 00170000 * THERE ARE A FEW ROUTINES ON THE MICRO SIDE THAT ARE UNIQUE * 00180000 * TO EACH OF THE PROGRAMS. THEY RESOLVE THE DIFFERENCES IN THE * 00190000 * DATASTREAMS BETWEEN THE TWO ACCESS METHODS. THE REST OF THE * 00200000 * FT3270 SERVER CODE RESIDES IN A COMMON LIBRARY IN THE MICRO * 00210000 * SOURCE CODE DEVELOPMENT ENVIRONMENT. * 00220000 * * 00230000 * FT3270 STILL NEEDS TO KNOW WHETHER IT IS TALKING VIA TN3270 * 00240000 * OR C19 IN ORDER TO DETERMINE BUFFER SIZES AND DATA FORMATTING. * 00250000 * THE MICRO RETURNS THIS INFORMATION IN THE FIRST PACKET. * 00260000 * * 00270000 * FT3270 CONSISTS OF THREE CMS SOURCE MODULES: * 00280000 * * 00290000 * 1. FT3270 CONTAINS CODE GOVERNING THE FOLLOWING: * 00300000 * A) SETTING UP THE APPLICATION ENVIRONMENT * 00310000 * B) ESTABLISHING CONTACT WITH THE MICRO COMPUTER * 00320000 * C) NEGOTIATING FILE TRANSFER WITH THE FT3270 SERVER * 00330000 * D) COPYING DATA BETWEEN CMS BUFFER AND FT3270 BUFFER * 00340000 * E) EBCDIC/ASCII TRANSLATION * 00350000 * F) SENDING & RECEIVING OF DATA VIA FULL SCREEN INTERFACE * 00360000 * G) CLOSING CONTACT WITH MICRO & RETURN TO CMS * 00370000 * 2. FTCMS HAS 2 ENTRY POINTS: * 00380000 * A) FTCMS IS CALLED INITIALLY TO PROCESS THE COMMAND LINE * 00390000 * PARAMETERS, VERIFY THEIR VALIDITY, AND SET SOME GLOBALS. * 00400000 * B) FTFS IS CALLED TO EXECUTE THE FS- MACROS. * 00410000 * 3. FTERR CONTAINS THE TEXT OF ALL OF THE ERROR MESSAGES. * 00420000 * * 00430000 * THE SUBROUTINE "CENTRAL" IN THIS MODULE IS THE BRIDGE BETWEEN * 00440000 * THE DATA BUFFERING ROUTINES AND THE DATA TRANSMISSION ROUTINES. * 00450000 * CURRENT BUFFER SIZES ARE SMALL ENOUGH TO ALLOW FOR WORST CASE * 00460000 * EXPANSION OF ILLEGAL CHARACTERS. * 00470000 * * 00480000 * ADDITIONAL DOCUMENTATION HAS BEEN WRITTEN ON THE FT3270 * 00490000 * PROTOCOL ITSELF. * 00500000 * * 00510000 * PETER HOYT CORNELL COMPUTER SERVICES * 00520000 * VERSION 2.0 AUGUST 30, 1987 * 00530000 * *XA 00540000 * MODIFIED TO PROVIDE SUPPORT FOR RUNNING IN AN XA-MODE *XA 00550000 * VIRTUAL MACHINE. THIS SOURCE FILE WAS ALSO SEQUENCED. *XA 00560000 * THIS CODE ALSO COMMUNICATES WITH 'COMET' ON THE MAC. *XA 00570000 * LARRY CHACE, CORNELL INFORMATION TECHNOLOGIES, 26 SEPT 1991 *XA 00580000 * *XA 00590000 ********************************************************************* 00600000 EJECT 00610000 FT3270 CSECT 00620000 EXTRN FTCMS 00630000 EXTRN FTERR 00640000 EXTRN FTFS 00650000 USING FT3270,R12 00660000 USING NUCON,R0 00670000 * 00680000 STM R14,R12,12(R13) SAVE THE CALLER'S THINGS. 00690000 LR R12,R15 GET OUR BASE ADDRESS. 00700000 B AROUND SKIP OUR EYECATCHER. XA 00710000 SPACE 1 XA 00720000 ICATCHER DC C'FT3270 1.00 &SYSDATE &SYSTIME ' XA 00730000 SPACE 1 XA 00740000 AROUND DS 0H XA 00750000 ST R13,SAVEAREA+4 SAVE HIS SAVE AREA AND 00760000 LA R13,SAVEAREA GET OURS. 00770000 * 00780000 LA R11,FTCOMMON 00790000 L R15,=A(FTCMS) 00800000 BALR R14,R15 PROCESS PARAMETERS 00810000 LTR R15,R15 CHECK RETURN CODE 00820000 BNZ ADONE 00830000 BAL R14,SETUP SET NEW PSW & GET CONSOLE ADDRESS 00840000 BAL R14,ESTAB ESTABLISH A CONNECTION WITH PC 00850000 CLI UPDOWN,C'D' DECIDE ON WHICH DIRECTION 00860000 BZ DOWNLOAD TO MOVE THE FILE. 00870000 B UPLOAD 00880000 * 00890000 DONE BAL R14,UNNEGOT IF EVERYTHING WENT OK 00900000 BAL R14,TERM 00910000 L R13,4(,R13) RESTORE EVERYTHING 00920000 LM R14,R12,12(R13) FROM THE CALLER 00930000 SR R15,R15 AND RETURN WITH 00940000 BR R14 A NICE CODE. 00950000 * 00960000 **** PUT OUT ERROR MESSAGE & RETURN WITH A NON-ZERO RETURN CODE 00970000 * 00980000 PDONE BAL R14,UNNEGOT TELL PC TO BECOME A TERMINAL AGAIN 00990000 TDONE BAL R14,TERM RESTORE PSW & MESSAGES 01000000 L R2,RETCMS 01010000 L R3,RETCODE 01020000 L R15,=A(FTERR) 01030000 BALR R14,R15 RC RETURNED IN R15 01040000 ADONE L R13,4(,R13) RESTORE EVERYTHING 01050000 L R14,12(R13) FROM THE CALLER 01060000 LM R0,R12,20(R13) EXCEPT R15! 01070000 BR R14 01080000 EJECT 01090000 *---------------------------------------------------------------------* 01100000 * ERROR HANDLER * 01110000 *---------------------------------------------------------------------* 01120000 REALTERM DS 0H 01130000 MVI RETCODE+3,60 COME HERE IF NOT A 3270. 01140000 B TDONE 01150000 LOSTTN MVI RETCODE+3,61 SOMEHOW LOST PC. 01160000 B PDONE 01170000 GONEAWAY MVI RETCODE+3,62 FAILURE IN IOREQ ROUTINE 01180000 B PDONE 01190000 USERHLT MVI RETCODE+3,63 USER PA1 KEY 01200000 B PDONE 01210000 MUSTQUIT MVI RETCODE+3,122 PF10 (X'7A') PC ABORT 01220000 B TDONE 01230000 BADVER1 MVI RETCODE+3,64 PC REJECTS OUR VERSION NO. 01240000 B PDONE 01250000 BADVER2 MVI RETCODE+3,65 WE REJECT PC'S VERSION NO. 01260000 B PDONE 01270000 BADNEGO MVI RETCODE+3,66 CHKSUM ERROR DURING NEGOTIATIONS 01280000 B PDONE 01290000 BADFMT MVI RETCODE+3,67 INVALID INTERNAL DATA STRUCTURE 01300000 B PDONE 01310000 NOMEM MVI RETCODE+3,50 DMSFREE FAILURE 01320000 B TDONE 01330000 TOOBIG MVI RETCODE+3,51 NOT ENOUGH CMS DISK SPACE 01340000 B PDONE 01350000 FSRERR MVI RETCODE+3,53 FSREAD FAILURE 01360000 ST R15,RETCMS 01370000 B PDONE 01380000 FSWER MVI RETCODE+3,54 FSWRITE FAILURE 01390000 ST R15,RETCMS 01400000 B PDONE 01410000 EJECT 01420000 *---------------------------------------------------------------------* 01430000 * 1) GET BUFFER SPACE FROM CMS MEMORY MANAGEMENT. * 01440000 * 2) GET READY TO DO FULL SCREEN I/O * 01450000 * 3) TURN OFF MESSAGES * 01460000 * ON EXIT: R10 POINTS TO CMS READ/WRITE BUFFER * 01470000 * R11 POINTS TO FT3270 COMMUNICATIONS BUFFER * 01480000 *---------------------------------------------------------------------* 01490000 SETUP DS 0H 01500000 L R0,DW64K GET 64K FOR CMS READ/WRITE BUFFER. 01510000 DMSFREE DWORDS=(0),ERR=NOMEM 01520000 LR R10,R1 01530000 L R0,DW16K GET 16K FOR FT3270 BUFFER. 01540000 DMSFREE DWORDS=(0),ERR=NOMEM 01550000 LR R11,R1 01560000 SLL R0,2 MAKE R0 CONTAIN X'2000' 01570000 AR R1,R0 TO POINT US 8K INTO BUFFER. 01580000 ST R1,TBUFFER USE THIS 8K FOR TEMPORARY BUFFER. 01590000 * 01600000 * CONSTRUCT SOME NEW PSWS SO THAT WE CAN GET CONTROL. XA 01610000 * XA 01620000 DMSEXS OC,IOWPSW(4),X'20' SNEAKILY DO A 'STORE PSW'. XA 01630000 ENABLE INTTYPE=NONE MAKE SURE WE HAVE QUIET. XA 01640000 DMSKEY NUCLEUS ENTER THE POWERFUL STATE. 01650000 LA R1,IOWAKE GET OUR INTERRUPT ADDRESS. XA 01660000 MVC XIONPSW,X'78' SAVE THE PREVIOUS I/O NEW PSW 01670000 ST R1,X'7C' AND TAKE OVER. XA 01680000 MVC XEXNPSW,X'58' SAVE THE PREVIOUS EXT NEW PSW 01690000 ST R1,X'5C' AND TAKE OVER. XA 01700000 DMSKEY RESET RETURN TO NORMAL POWER. 01710000 * 01720000 L R1,=F'-1' GO FIND THE 01730000 DIAG R1,R2,X'24' CONSOLE ADDRESS. 01740000 BNZ REALTERM IF DISCONNECTED, COMPLAIN. XA 01750000 ST R1,XTERMADD SAVE THE CONSOLE ADDRESS, 01760000 MVI XTERMADD,0 AND BE SURE IT IS PURE. 01770000 CLM R3,B'1000',=X'40' IF IT IS NOT A 3270, 01780000 BNE REALTERM THEN GO COMPLAIN LOUDLY. 01790000 * 01800000 LA R1,CPMSGOFF 01810000 LA R2,CPOFFLEN 01820000 DIAG R1,R2,X'08' TURN OFF MESSAGES. 01830000 SPACE 1 01840000 * FOR XA MODE, WE MUST FIND THE SUBCHANNEL FOR THE CONSOLE. XA 01850000 TM NUCMFLAG,NUCMXA IF WE ARE NOT IN XA MODE, XA 01860000 BNO SET190 THEN WE ARE DONE HERE. XA 01870000 L R1,=X'00010000' GET THE FIRST SUBCHANNEL. XA 01880000 SET100 DS 0H XA 01890000 STSCH SCHIB TRY THIS SUBCHANNEL AND XA 01900000 BC 1,REALTERM COMPLAIN IF NO CONSOLE. XA 01910000 TM SCHCTL,SCHVLD IF THIS IS NOT A VALID DEVICE, XA 01920000 BNO SET110 THEN GO TRY THE NEXT ONE. XA 01930000 SPACE 1 XA 01940000 CLC SCHDEV,XTERMADD+2 IF THIS IS THE TERMINAL, XA 01950000 BE SET120 THEN WE CAN STOP LOOKING. XA 01960000 SET110 DS 0H XA 01970000 LA R1,=F'1' GET THE NEXT SUBCHANNEL NUMBER XA 01980000 B SET100 AND KEEP ON SEARCHING. XA 01990000 SPACE 1 XA 02000000 SET120 DS 0H XA 02010000 ST R1,TIOSUBCH SAVE THE TERMINAL SUBCHANNEL. XA 02020000 SET190 DS 0H XA 02030000 SPACE 1 XA 02040000 BR 14 02050000 EJECT 02060000 *---------------------------------------------------------------------* 02070000 * TERMINATION: DMSFRET, RESTORE PSW, TURN MESSAGES ON * 02080000 *---------------------------------------------------------------------* 02090000 TERM DS 0H 02100000 L R0,DW64K FREE 64K 02110000 LR R1,R10 THE CMS READ/WRITE BUFFER 02120000 DMSFRET DWORDS=(0),LOC=(1) 02130000 * 02140000 L R0,DW16K FREE 16K 02150000 LR R1,R11 THE FT3270 TRANSFER BUFFER 02160000 DMSFRET DWORDS=(0),LOC=(1) 02170000 * 02180000 DMSKEY NUCLEUS BECOME POWERFUL FOR NOW. 02190000 MVC X'78'(8),XIONPSW RESTORE THE PSW. 02200000 MVC X'58'(8),XEXNPSW RESTORE THE PSW. 02210000 DMSKEY RESET RETURN TO NORMAL. 02220000 * 02230000 LA R1,CPMSGON 02240000 LA R2,CPONLEN 02250000 DIAG R1,R2,X'08' TURN MESSAGES BACK ON. 02260000 BR 14 ALL DONE NOW. 02270000 EJECT 02280000 *---------------------------------------------------------------------* 02290000 * ESTABLISH CONNECTION WITH PC RUNNING FT3270. * 02300000 * USE SPECIAL HANDSHAKING TO CONVERT PC INTO FILE TRANSFER MACHINE * 02310000 *---------------------------------------------------------------------* 02320000 ESTAB DS 0H 02330000 ST R14,XESTA14 SAVE OUR RETURN POINTER. 02340000 LA R0,ZERASE CLEAR THE SCREEN TO ALLOW 02350000 BAL R14,IOREQ FULL-SCREEN OPERATIONS. 02360000 * 02370000 MVC ZLENGTH(73),XESTAB SPECIAL FIELD FOR INITIAL CONTACT 02380000 LA R8,80 7 + 73 02390000 STH R8,ZSND+6 COMPLETE THE CCW 02400000 LA R0,ZSND POINT TO THE CCW AND 02410000 BAL R14,IOREQ GO WRITE IT. 02420000 BAL R14,IOWAIT WAIT FOR AN ATTENTION. 02430000 LA R0,ZRCV CCW FOR READ. 02440000 BAL R14,IOREQ GET THE BUFFER FROM THE PC. 02450000 CLI ZRCVBUFF,X'E8' THIS BYTE'S FOR 7171! 02460000 BNZ REALTERM 02470000 CLI ZLENGTH,X'FD' 02480000 BNZ REALTERM 02490000 * 02500000 NI ZLENGTH+2,X'7F' 02510000 LA R9,C19FTLEN DEFAULT SMALL BUFFERS 02520000 MVC C19FLAG(1),ZLENGTH+2 02530000 CLI C19FLAG,X'00' SEE WHETHER WE ARE RUNNING TN 02540000 BNZ ESTAB3 02550000 LA R9,TNFTLEN 02560000 ESTAB3 ST R9,FTLEN STORE DOWNLOAD BUFFER SIZE 02570000 * 02580000 L R14,XESTA14 RESTORE RETURN REGISTER. 02590000 NI ZLENGTH+1,X'7F' 02600000 CLC ZLENGTH+1(1),ESCCHAR DID PC REJECT OUR VERSION NUMBER? 02610000 BZ BADVER1 02620000 LA R9,VTABLE SEE IF WE ACCEPT PC'S VERSION NO. 02630000 * 02640000 ESTAB2 CLI 0(R9),X'FF' END OF TABLE? 02650000 BZ BADVER2 02660000 IC R3,0(,R9) 02670000 CLC 0(1,R9),ZLENGTH+1 IS IT IN THE TABLE? 02680000 BZR R14 IF SO, RETURN. 02690000 LA R9,1(,R9) NEXT TABLE ENTRY 02700000 B ESTAB2 02710000 EJECT 02720000 *---------------------------------------------------------------------* 02730000 * THIS ROUTINE CONTROLS THE UPLOADING OF A FILE FROM THE PC. * 02740000 * REG. USAGE: R6 & R7 ARE INDICES INTO BUFFERS (R10 & R11). * 02750000 * R8 IS LOOP COUNTER FOR PROCESSING OF PC BUFFER. * 02760000 * R2 IS USED TO CALL FS ROUTINES. * 02770000 * R3 IS USED TO LOAD & TRANSLATE THE RECEIVED BYTE. * 02780000 * R5 IS USED TO BASE THE ASCII/EBCDIC XLATE TABLE. * 02790000 * R9 IS TO TEST WHEN CMS BUFFER FULL (LRECL OR EOR). * 02800000 *---------------------------------------------------------------------* 02810000 UPLOAD DS 0H 02820000 MVI NEGO+1,X'0A' NEGOTIATE WITH PC 02830000 BAL R14,NEGOTY 02840000 L R3,2(,R11) GET FILESIZE IN BYTES 02850000 C R3,BYTELEFT SEE IF SPACE ON CMS DISK. 02860000 BC 2,TOOBIG 02870000 SR R6,R6 RESET OUTPUT RECORD LENGTH. 02880000 SR R3,R3 CLEAR CHARACTER BUFFER. 02890000 LA R5,EBCDTAB ASCII/EBCDIC XLATE TABLE 02900000 * 02910000 UP0 BAL R14,SHIPUP GET ANOTHER BUFFER FROM THE PC. 02920000 LTR R8,R8 ARE WE DONE? 02930000 BNZ UP1 NOPE, CONTINUE. 02940000 LTR R6,R6 SEE IF ANY DATA REMAINING 02950000 BZ UP8 IF NOT THEN CLOSE THE FILE. 02960000 CLI CRECFM+3,C'V' FIXED OR VARIABLE? 02970000 BZ UP6 JUST WRITE WHAT WE'VE GOT. 02980000 L R9,CLRECL GET FIXED RECORD LENGTH. 02990000 B UP2 PROCESS AS EOR. 03000000 * 03010000 UP1 IC R3,1(R7,R11) GET NEXT CHARACTER 03020000 L R9,CLRECL DEFAULT WRITE RECORD LENGTH. 03030000 CLI BINTEXT,C'B' NO LINEFEED OR XLATE IN BINARY FILE! 03040000 BZ UP5 03050000 CLM R3,1,HEXEOR LOOK FOR LINE FEED ON TEXT FILES. 03060000 BZ UP2 03070000 IC R3,0(R3,R5) PERFORM XLATE. 03080000 B UP5 GO STORE THE CHARACTER. 03090000 * 03100000 UP2 IC R3,=C' ' GET THE PAD CHARACTER. 03110000 CLI CRECFM+3,C'F' FIXED OR VARIABLE? 03120000 BZ UP3 03130000 LA R9,1(,R6) FORCE THIS VARIABLE RECORD OUT. 03140000 LTR R6,R6 IS THIS A ZERO LENGTH RECORD? 03150000 BZ UP5 PAD ONE BLANK TO CREATE A RECORD. 03160000 B UP6 JUST WRITE IT OUT AS IS. 03170000 * 03180000 UP3 CLI WRFLAG,X'0' WAS LAST WRITE WITH FULL BUFFER? 03190000 BNZ UP7 YES, IGNORE THIS NEWLINE CHARACTER. 03200000 MVI WRFLAG,X'0' RESET FIXED LENGTH FULL FLAG. 03210000 SR R9,R6 NUMBER OF BYTES LEFT TO FILL. 03220000 UP4 STC R3,0(R6,R10) OTHERWISE STORE A BLANK 03230000 LA R6,1(,R6) & INC. POINTER. 03240000 BCT R9,UP4 DO UNTIL RECORD IS FULL. 03250000 B UP6 03260000 EJECT 03270000 *---------------------------------------------------------------------* 03280000 * ...... CONTINUATION OF UPLOAD ROUTINE ....... * 03290000 * THIS IS NORMAL CONTINUATION AFTER GETTING NEXT CHARACTER; * 03300000 * IE: ALWAYS BINARY FILES & TEXT FILES WITH OTHER THAN NEWLINE. * 03310000 *---------------------------------------------------------------------* 03320000 UP5 STC R3,0(R6,R10) STORE THE CHARACTER 03330000 LA R6,1(,R6) AND INCREMENT LENGTH. 03340000 CR R6,R9 IS CMS WRITE BUFFER FULL YET? 03350000 BNZ UP7 NO, SO CONTINUE. 03360000 MVI WRFLAG,X'1' SET FIXED LENGTH FULL FLAG. 03370000 * 03380000 UP6 LA R2,2 DO AN FSWRITE 03390000 L R3,CRECFM FIXED OR VARIABLE 03400000 L R15,=A(FTFS) EXTERNAL ROUTINE FOR FS CALLS 03410000 BALR R14,R15 03420000 LTR R15,R15 CHECK RETURN CODE 03430000 BNZ FSWER 03440000 SR R6,R6 RESET RECORD LENGTH 03450000 * 03460000 UP7 LA R7,1(,R7) NEXT CHARACTER FROM PC 03470000 S R8,=F'1' BYTES LEFT IN PC BUFFER 03480000 BC 2,UP1 LOOP UNTIL NO MORE FROM PC 03490000 BC 8,UP0 GET MORE DATA FROM PC 03500000 * 03510000 UP8 LA R2,3 DO AN FSCLOSE 03520000 L R15,=A(FTFS) EXTERNAL ROUTINE FOR FS CALLS 03530000 BALR R14,R15 03540000 B DONE 03550000 *---------------------------------------------------------------------* 03560000 * LET THE PC SEND US ANOTHER PACKET OF DATA * 03570000 * RETURNS A NUMBER OF BYTES TO PROCESS IN R8 * 03580000 *---------------------------------------------------------------------* 03590000 SHIPUP DS 0H 03600000 ST R14,SHIP14 03610000 MVI NEGO+1,X'0A' FIRST REQUEST IS NOT A RETRANSMIT 03620000 SU0 LA R1,NEGO 03630000 LA R8,2 03640000 BAL R14,CENTRAL COMMUNICATIONS INTERFACE ROUTINE 03650000 LTR R8,R8 LENGTH OF RETURNED PACKET 03660000 BZ SU1 WE'LL REQUEST RE-XMISSION 03670000 * 03680000 CLI 0(R11),X'7D' ENTER INDICATES OK XFER. 03690000 BZ SU4 03700000 CLI 0(R11),X'6E' PA2 INDICATES EOF 03710000 BZ SU3 RETURN A ZERO LENGTH. 03720000 CLI 0(R11),X'6B' SEE IF "PA3" WAS RETURNED. 03730000 BZ SU0 RE-TRANSMIT THE REQUEST 03740000 SU1 MVI NEGO+1,X'0B' RETRANSMIT CODE 03750000 B SU0 03760000 * 03770000 SU3 LA R8,1 COME HERE IF EOF HAS OCCURRED. 03780000 SU4 BCTR R8,0 RC DOSEN'T COUNT TOWARD LENGTH 03790000 SR R7,R7 RESET INDEX INTO PC BUFFER. 03800000 L R14,SHIP14 RESTORE & RETURN. 03810000 BR R14 03820000 EJECT 03830000 *---------------------------------------------------------------------* 03840000 * THIS ROUTINE CONTROLS THE DOWNLOADING OF A FILE TO THE PC. * 03850000 * REG. USAGE: R6 & R7 ARE INDICES INTO BUFFERS (R10 & R11). * 03860000 * R4 IS LOOP COUNTER FOR PROCESSING OF CMS BUFFER. * 03870000 * R9 IS LOOP COUNTER FOR FSREAD. * 03880000 * R3 IS USED TO LOAD & TRANSLATE THE BYTE TO SEND. * 03890000 * R5 IS USED TO BASE THE EBCDIC/ASCII XLATE TABLE. * 03900000 * R2 IS USED TO CALL FSREAD. * 03910000 * R8 & R1 ARE USED BY LOWER LEVEL ROUTINES. * 03920000 *---------------------------------------------------------------------* 03930000 DOWNLOAD DS 0H 03940000 MVC NEGO+2(4),NUMBYTES FILESIZE TO DOWNLOAD 03950000 MVI NEGO+1,X'08' NEGOTIATE WITH PC 03960000 BAL R14,NEGOTY 03970000 SR R7,R7 INDEX INTO R11 (PC BUFFER) 03980000 SR R3,R3 CLEAR CHARACTER BUFFER. 03990000 LA R5,ASCIITAB EBCDIC/ASCII XLATE TABLE 04000000 L R9,XNOREC NUMBER OF CMS RECORDS TO READ 04010000 MVC 0(2,R11),=X'0808' INDICATES DOWNLOAD 04020000 * 04030000 DV0 LA R2,1 DO AN FSREAD 04040000 L R15,=A(FTFS) EXTERNAL ROUTINE FOR FS CALLS 04050000 BALR R14,R15 04060000 LTR R15,R15 CHECK RETURN CODE 04070000 BNZ FSRERR 04080000 * 04090000 LR R4,R0 NUMBER OF BYTES READ FROM CMS 04100000 SR R6,R6 INDEX INTO R10 (CMS BUFFER) 04110000 CLI BINTEXT,C'B' GET RID OF TRAILING BLANKS 04120000 BZ DV1 NO STRIPPING OF BINARY FILES 04130000 * 04140000 SO1 S R4,=F'1' LAST BYTE IS BASE + (LEN - 1) 04150000 BC 4,DV2 IF < 0, RECORD IS ALL BLANKS 04160000 IC R3,0(R4,R10) 04170000 CLM R3,1,=X'40' TEST FOR NON BLANK 04180000 BZ SO1 WE FOUND ANOTHER BLANK 04190000 LA R4,1(,R4) RESTORE CORRECT LENGTH 04200000 * 04210000 DV1 IC R3,0(R6,R10) GET NEXT CHARACTER FROM CMS BUFFER. 04220000 CLI BINTEXT,C'B' DECIDE WHETHER TO DO XLATE. 04230000 BZ DV21 NOT FOR BINARY FILES 04240000 IC R3,0(R3,R5) GET TABLE ENTRY. 04250000 * 04260000 DV21 STC R3,2(R7,R11) PUT BYTE INTO PC BUFFER. 04270000 LA R6,1(,R6) INCREMENT INDICES. 04280000 LA R7,1(,R7) 04290000 C R7,FTLEN BUFFER FULL YET? 04300000 BC 4,DV11 NO 04310000 MVI 1(R11),X'08' INDICATE NOT LAST PACKET. 04320000 BAL R14,SHIPDOWN YES, SO SEND IT TO THE PC 04330000 DV11 BCT R4,DV1 LOOP WHILE NON TRAILING BLANKS 04340000 EJECT 04350000 *---------------------------------------------------------------------* 04360000 * .....CONTINUATION OF DOWNLOAD ROUTINE..... * 04370000 * WE COME HERE WHEN WE HAVE REACHED THE END OF A CMS RECORD. * 04380000 *---------------------------------------------------------------------* 04390000 DV2 CLI BINTEXT,C'B' NO LINEFEED INSERTED IN BINARY FILE! 04400000 BZ DV4 04410000 IC R3,HEXEOR USE ASCII LF TO INDICATE EOR. 04420000 STC R3,2(R7,R11) STORE IT & BUMP INDEX. 04430000 LA R7,1(,R7) 04440000 * 04450000 DV4 BCT R9,DV0 GET ANOTHER RECORD IF AVAILABLE 04460000 MVI 1(R11),X'09' INDICATE LAST PACKET. 04470000 BAL R14,SHIPDOWN DOWNLOAD THE LAST OF THE DATA 04480000 B DONE 04490000 *---------------------------------------------------------------------* 04500000 * THIS ROUTINE CUTS A SCREEN LOOSE TO THE PC * 04510000 * R7 CONTAINS LENGTH OF BUFFER TO SEND & IS RESET UPON EXIT * 04520000 *---------------------------------------------------------------------* 04530000 SHIPDOWN DS 0H 04540000 ST R14,SHIP14 04550000 LA R7,2(R7) 04560000 SD0 MVI 0(R11),X'08' INDICATE FT3270 CODE. 04570000 LR R1,R11 04580000 LR R8,R7 04590000 SD1 BAL R14,CENTRAL COMMUNICATIONS INTERFACE ROUTINE 04600000 LTR R8,R8 LENGTH OF RETURNED PACKET 04610000 BZ SD3 04620000 * 04630000 CLI 0(R11),X'6B' SEE IF "PA3" WAS RETURNED. 04640000 BZ SD0 RE-TRANSMIT THE DATA 04650000 CLI 0(R11),X'7D' SEE IF "ENTER" WAS RETURNED. 04660000 BZ SD5 04670000 SD3 LA R1,NEGO 04680000 LA R8,2 04690000 MVI NEGO+1,X'0B' REQUEST RETRANSMISSION 04700000 B SD1 04710000 * 04720000 SD5 L R14,SHIP14 RESTORE THE REGISTER 04730000 SR R7,R7 RESET INDEX REGISTER. 04740000 BR R14 04750000 EJECT 04760000 *---------------------------------------------------------------------* 04770000 * THIS ROUTINE NEGOTIATES FILE TRANSFER WITH THE PC. * 04780000 * RESOLVES DEFAULT CONVERSION IF NECESSARY. * 04790000 *---------------------------------------------------------------------* 04800000 NEGOTY DS 0H 04810000 ST R14,NEGO14 SAVE OUR RETURN POINTER. 04820000 NEGO1 LA R1,NEGO 04830000 L R8,FSPECLEN 04840000 A R8,=F'7' NEGOTIATION HEADER 04850000 BAL R14,CENTRAL COMMUNICATIONS INTERFACE ROUTINE 04860000 LTR R8,R8 LENGTH OF RETURNED PACKET 04870000 BZ BADNEGO 04880000 * 04890000 CLI 0(R11),X'6B' SEE IF "PA3" WAS RETURNED. 04900000 BZ NEGO1 RESEND THE PACKET 04910000 CLI 0(R11),X'7D' SEE IF "ENTER" WAS RETURNED. 04920000 BZ NEGO2 04930000 MVC RETCODE+3(1),0(R11) ERROR NEGOTIATING WITH PC 04940000 B PDONE 04950000 * 04960000 NEGO2 CLI BINTEXT,C'D' USING A DEFAULT CONVERSION? 04970000 BNZ NEGO3 CONVERSION ALREADY DETERMINED. 04980000 MVI BINTEXT,C'B' LET'S SAY BINARY FOR NOW. 04990000 CLI 1(R11),X'00' SEE IF PC AGREES. 05000000 BZ NEGO3 05010000 MVI BINTEXT,C'T' CHANGE IT TO TEXT. 05020000 * 05030000 NEGO3 CLI C19FLAG,X'0' CONTINUE 8 FOR 7 CONVERSIONS? 05040000 BZ NEGO4 NOT IF RUNNING TN. 05050000 CLI BINTEXT,C'B' IF C19, THEN IS IT BINARY? 05060000 BZ NEGO5 IF SO THEN CONTINUE CONVERSIONS. 05070000 NEGO4 MVI NOSTRIP,X'1' DO IT NO LONGER. 05080000 NEGO5 L R14,NEGO14 RESTORE AND 05090000 BR R14 RETURN. 05100000 *---------------------------------------------------------------------* 05110000 * THIS ROUTINE SENDS THE "UNNEGOTIATION" SEQUENCE TO THE PC * 05120000 * AVOID MULTIPLE EXECUTIONS OF THIS DUE TO PC FOUL UP. * 05130000 *---------------------------------------------------------------------* 05140000 UNNEGOT DS 0H 05150000 CLI UNNFLAG,X'1' TEST FOR NESTED CALLS 05160000 BZR R14 IF SO, THEN SKIP IT 05170000 MVI UNNFLAG,X'1' ELSE SET FLAG 05180000 * 05190000 ST R14,NEGO14 SAVE OUR RETURN POINTER. 05200000 MVI NEGO,X'09' UNNEGOTIATE WITH PC 05210000 LA R1,NEGO 05220000 LA R8,1 05230000 BAL R14,CENTRAL COMMUNICATIONS INTERFACE ROUTINE 05240000 * 05250000 L R14,NEGO14 RESTORE AND 05260000 BR R14 RETURN. 05270000 EJECT 05280000 *---------------------------------------------------------------------* 05290000 * INTERFACE BETWEEN BUFFER PROCESSING & COMMUNICATIONS ROUTINES. * 05300000 * THIS SUBROUTINE IS CALLED BY THE HIGHER LEVEL ROUTINE * 05310000 * { SHIPUP, SHIPDOWN, NEGOTY, UNNEGOT } * 05320000 * AND IN TURN CALLS ROUTINES TO CONVERT THE DATA TO 7 BITS, * 05330000 * CALCULATE CHECKSUM, SEND THE DATA, WAIT FOR RESPONSE, & UNWRAP * 05340000 * THE RETURNED DATA. * 05350000 * ON ENTRY: R1 CONTAINS ADDRESS OF BUFFER TO SEND * 05360000 * R8 CONTAINS THE LENGTH OF THE DATA * 05370000 * ON EXIT: R8 RETURNS THE LENGTH OF THE RECEIVED DATA OR ZERO * 05380000 * IF AN ERROR HAS BEEN DETECTED. * 05390000 * ALL OTHER REGISTERS ARE RESTORED. * 05400000 *---------------------------------------------------------------------* 05410000 CENTRAL DS 0H 05420000 STM R9,R7,XCENTRAL SAVE REGISTERS 05430000 CLI NOSTRIP,X'0' SHALL WE PERFORM 8 FOR 7 CONVERSION? 05440000 BNZ CEN1 05450000 BAL R14,BITSTRP CONVERT TO 7 BIT DATA 05460000 CEN1 BAL R14,COPYOUT COVER ESCAPE SEQUENCES 05470000 BAL R14,SNDPKT SEND THE DATA 05480000 * 05490000 LTR R8,R8 LENGTH OF RETURNED PACKET 05500000 BZ CEN9 05510000 CLI C19FLAG,X'0' ARE WE RUNNING C19? 05520000 BZ CEN2 05530000 LA R1,ZBUFFER SOURCE BUFFER 05540000 LR R3,R8 LOOP COUNTER 05550000 CENLOOP NI 0(R1),X'7F' GET RID OF HIGH BIT FROM 7171 05560000 LA R1,1(,R1) INC. BUFFER POINTER 05570000 BCT R3,CENLOOP GO FOR THE NEXT ONE 05580000 * 05590000 CEN2 L R1,TBUFFER DEFAULT TARGET BUFFER 05600000 CLI NOSTRIP,X'0' WILL WE PERFORM 8 FOR 7 CONVERSION? 05610000 BZ CEN3 YES.. 05620000 LR R1,R11 ELSE USE FT3270 BUFFER FOR TARGET. 05630000 CEN3 BAL R14,COPYIN GET RID OF ESCAPE SEQUENCES 05640000 LTR R8,R8 LENGTH OF RETURNED PACKET 05650000 BZ CEN9 INDICATES CHKSUM ERROR 05660000 CLI NOSTRIP,X'0' SHALL WE PERFORM 8 FOR 7 CONVERSION? 05670000 BNZ CEN4 05680000 BAL R14,BITREST MAKE 8 BYTE DATA ONCE AGAIN 05690000 * 05700000 CEN4 LM R9,R7,XCENTRAL RESTORE REGISTERS. 05710000 CLI 0(R11),X'6C' SEE IF "PA1" WAS RETURNED. 05720000 BZ USERHLT 05730000 CLI 0(R11),X'7A' SEE IF "PF10" WAS RETURNED. 05740000 BZ MUSTQUIT 05750000 BR R14 RETURN DATA OK. 05760000 CEN9 LM R9,R7,XCENTRAL RESTORE & 05770000 BR R14 RETURN WITH ERROR. 05780000 EJECT 05790000 *---------------------------------------------------------------------* 05800000 * ROUTINE TO RESTORE HIGH ORDER BITS FROM EVERY 8TH BYTE. * 05810000 * ON ENTRY: R8 CONTAINS LENGTH * 05820000 * ON EXIT: R8 CONTAINS NEW LENGTH * 05830000 *---------------------------------------------------------------------* 05840000 BITREST DS 0H 05850000 L R1,TBUFFER SOURCE BUFFER 05860000 LR R2,R11 TARGET BUFFER 05870000 LR R3,R8 LOOP COUNTER 05880000 * 05890000 BITR2 LA R9,8 NUMBER OF BYTES TO CONSIDER AT ONCE 05900000 SR R3,R9 REDUCE LENGTH REMAINING 05910000 BC 10,BITR7 DID NOT GO NEGATIVE 05920000 AR R9,R3 IF IT DID, REDUCE CONSIDERATION 05930000 BITR7 S R9,=F'1' WE REALLY ONLY PROCESS 7 BYTES 05940000 BZ BADFMT IF THIS IS ZERO, WE WENT WRONG 05950000 LA R5,0(R9,R1) ADDRESS OF THE BITS BYTE 05960000 BCTR R8,0 REAL LENGTH GETS DECREMENTED TOO 05970000 * 05980000 BITR0 IC R6,0(,R1) GET NEXT CHAR 05990000 LA R1,1(,R1) AND INC. POINTER 06000000 TM 0(R5),X'01' IS THE HIGH BIT ON? 06010000 BC 8,BITR1 IF NOT SKIP.. 06020000 O R6,=F'128' ELSE TURN ON HIGH ORDER BIT 06030000 BITR1 IC R7,0(,R5) SLIDE THE BIT DOWN. 06040000 SRL R7,1 06050000 STCM R7,1,0(R5) REPLACE THE BIT MAP IN STORAGE 06060000 STCM R6,1,0(R2) PUT BYTE INTO OUTPUT BUFFER 06070000 LA R2,1(,R2) AND INC. POINTER. 06080000 BCT R9,BITR0 GO & GET THE NEXT BYTE. 06090000 * 06100000 LA R1,1(,R1) MOVE SOURCE PTR PAST BITS BYTE 06110000 LTR R3,R3 IS THERE MORE TO DO? 06120000 BC 2,BITR2 06130000 BR R14 RETURN. 06140000 EJECT 06150000 *---------------------------------------------------------------------* 06160000 * VERIFY CHECKSUM & REPLACE ESCAPE SEQUENCES WITH CORRECT DATA. * 06170000 * ON ENTRY: R8 LENGTH OF RECEIVED DATA * 06180000 * R6 CONTAINS CHECKSUM * 06190000 * R1 CONTAINS TARGET BUFFER * 06200000 * ON EXIT: R8 CONTAINS NEW LENGTH (0 IF CHKSUM ERROR) * 06210000 *---------------------------------------------------------------------* 06220000 COPYIN DS 0H 06230000 ST R14,CISR14 06240000 LR R5,R6 SAVE CHECKSUM FROM HEADER 06250000 LA R2,ZBUFFER SOURCE BUFFER 06260000 BAL R14,CHKSUM 06270000 CR R6,R5 COMPARE CHKSUMS 06280000 BZ CIOKAY OK CONTINUE 06290000 SR R8,R8 RETURN WITH ZERO LENGTH 06300000 B CI99 06310000 * 06320000 CIOKAY LR R2,R1 TARGET BUFFER 06330000 LA R1,ZBUFFER SOURCE BUFFER 06340000 LR R3,R8 LOOP COUNTER 06350000 * 06360000 CILOOP CLC 0(1,R1),ESCCHAR IS THIS THE ESCAPE CHARACTER? 06370000 BNZ CI9 NO SO JUST CONTINUE 06380000 LA R1,1(,R1) INC. INPUT POINTER 06390000 BCTR R8,0 DEC. LENGTH COUNTERS 06400000 S R3,=F'1' 06410000 BZ BADFMT SHOULD NEVER GO TO 0 HERE 06420000 * 06430000 CLC 0(1,R1),ESCCHAR NOW IS THIS THE ESCAPE CHARACTER? 06440000 BZ CI9 CODE FOR ESCAPE IS ITSELF 06450000 * 06460000 NI 0(R1),X'0F' GET RID OF HIGH NIBBLE 06470000 SR R9,R9 USE THE ESCAPE CODE 06480000 IC R9,0(,R1) AS INDEX INTO TABLE 06490000 IC R9,CITABLE(R9) REPLACE THE CHARACTER 06500000 STC R9,0(,R1) PUT IT BACK INTO BUFFER 06510000 * 06520000 CI9 MVC 0(1,R2),0(R1) COPY THE CHARACTER 06530000 LA R1,1(,R1) INC. INPUT POINTER 06540000 LA R2,1(,R2) INC. OUTPUT POINTER 06550000 BCT R3,CILOOP GO FOR THE NEXT ONE 06560000 * 06570000 CI99 L R14,CISR14 RESTORE & 06580000 BR R14 RETURN 06590000 EJECT 06600000 *---------------------------------------------------------------------* 06610000 * ROUTINE TO STRIP HIGH ORDER BITS & STORE IN EVERY 8TH BYTE. * 06620000 * ON ENTRY: R8 CONTAINS LENGTH OF ORIGINAL STRING * 06630000 * R1 CONTAINS POINTER TO SOURCE BUFFER * 06640000 * ON EXIT: R8 CONTAINS LENGTH OF OUTPUT STRING * 06650000 * R1 CONTAINS POINTER TO NEW SOURCE BUFFER * 06660000 *---------------------------------------------------------------------* 06670000 BITSTRP DS 0H 06680000 L R2,TBUFFER TARGET BUFFER 06690000 LR R3,R8 LOOP COUNT 06700000 * 06710000 BITS2 SR R5,R5 WHERE THE HIGH BITS GET PUT 06720000 LTR R3,R3 IS THERE ANYTHING LEFT? 06730000 BC 12,BITS6 R3 <= 0 RETURN 06740000 LA R7,7 NUMBER OF BYTES TO CONSIDER AT ONCE 06750000 SR R3,R7 REDUCE LENGTH REMAINING 06760000 BC 10,BITS0 DID NOT GO NEGATIVE 06770000 AR R7,R3 IF IT DID, REDUCE CONSIDERATION 06780000 * 06790000 BITS0 IC R6,0(,R1) GET NEXT CHAR 06800000 TM 0(R1),X'80' IS THE HIGH BIT ON? 06810000 LA R1,1(,R1) AND INC. POINTER 06820000 BC 8,BITS1 IF NOT SKIP.. 06830000 O R5,=F'128' ELSE ADD A BIT TO 8TH BYTE 06840000 BITS1 SRL R5,1 SLIDE THE BIT DOWN. 06850000 N R6,=F'127' GET RID OF HIGH BIT IN ORIGINAL BYTE. 06860000 STCM R6,1,0(R2) PUT BYTE INTO OUTPUT BUFFER 06870000 LA R2,1(,R2) AND INC. POINTER. 06880000 BCT R7,BITS0 GO & GET THE NEXT BYTE. 06890000 * 06900000 CR R3,R7 WAS THIS LAST FILL LESS THAN 7 BYTES? 06910000 BC 10,BITS4 DETERMINED BY LENGTH REMAINING < 0 06920000 MH R3,=H'-1' IF SO WE SHIFT BY THE DIFFERENCE. 06930000 BITS5 SRL R5,1 06940000 BCT R3,BITS5 06950000 BITS4 STCM R5,1,0(R2) PUT 8TH BYTE INTO OUTPUT BUFFER 06960000 LA R2,1(,R2) AND INC. POINTER. 06970000 LA R8,1(,R8) INC LENGTH OF STRING TO SEND. 06980000 B BITS2 06990000 * 07000000 BITS6 L R1,TBUFFER RETURN SOURCE BUFFER FOR COPYOUT 07010000 BR R14 07020000 EJECT 07030000 *---------------------------------------------------------------------* 07040000 * COPY DATA FROM PROG BUFFER TO OUT BOUND BUFFER * 07050000 * SUBSTITUTE ESCAPE SEQUENCES FOR DANGEROUS CHARACTERS * 07060000 * ON ENTRY: R1 CONTAINS SOURCE BUFFER * 07070000 * R8 CONTAINS LENGTH * 07080000 * ON EXIT: R6 CONTAINS CHKSUM * 07090000 * R8 CONTAINS LENGTH * 07100000 *---------------------------------------------------------------------* 07110000 COPYOUT DS 0H 07120000 ST R14,COSR14 07130000 LA R2,ZBUFFER TARGET BUFFER 07140000 LR R3,R8 LOOP COUNTER 07150000 SR R7,R7 WORKING REGISTER 07160000 * 07170000 COLOOP IC R7,0(,R1) LOAD THE NEXT CHARACTER 07180000 CLC 0(1,R1),ESCCHAR IS THIS THE ESCAPE CHARACTER? 07190000 BZ CO8 CODE FOR ESCAPE IS ITSELF 07200000 LA R5,COTABLE TABLE OF CHARACTERS 07210000 LA R9,COTABLEN LENGTH OF TABLE 07220000 * 07230000 CO2 CLC 0(1,R1),0(R5) IS THIS A DANGEROUS? 07240000 BZ CO7 A HIT! 07250000 LA R5,1(,R5) NEXT ENTRY 07260000 BCT R9,CO2 07270000 B CO9 NO SUBSTITUTIONS 07280000 * 07290000 CO7 LA R9,COTABLE 07300000 SR R5,R9 GET THE OFFSET INTO THE TABLE 07310000 STC R5,0(,R1) STORE THE INDEX 07320000 OI 0(R1),X'40' AND MAKE AN ASCII CHARACTER 07330000 * 07340000 CO8 MVC 0(1,R2),ESCCHAR SUBSTITUTE THE ESCAPE CHAR 07350000 LA R2,1(,R2) INC. OUTPUT POINTER 07360000 LA R8,1(,R8) INC. LENGTH COUNTER 07370000 * 07380000 CO9 MVC 0(1,R2),0(R1) COPY THE CHARACTER 07390000 LA R1,1(,R1) INC. INPUT POINTER 07400000 LA R2,1(,R2) INC. OUTPUT POINTER 07410000 BCT R3,COLOOP GO FOR THE NEXT ONE 07420000 * 07430000 LA R2,ZBUFFER TARGET BUFFER 07440000 BAL R14,CHKSUM GO CALCULATE THE CHKSUM 07450000 L R14,COSR14 RESTORE & 07460000 BR R14 RETURN 07470000 EJECT 07480000 *---------------------------------------------------------------------* 07490000 * PERFORM A 16 BIT ONES COMPLEMENT CHECKSUM ON PASSED FIELD. * 07500000 * IF NECESSARY, FIELD IS ZERO PADDED ON RIGHT FOR COMPUTATION. * 07510000 * ON ENTRY: R2 CONTAINS FIELD * 07520000 * R8 CONTAINS LENGTH (PRESERVED) * 07530000 * ON EXIT: R6 CONTAINS ONES COMPLEMENT OF CHECKSUM * 07540000 *---------------------------------------------------------------------* 07550000 CHKSUM DS 0H 07560000 LR R3,R2 07570000 AR R3,R8 POINT TO END OF BUFFER 07580000 MVI 0(R3),X'00' STORE ZERO AT END OF BUFFER 07590000 LR R3,R8 LENGTH PASSED IN BYTES 07600000 LA R3,1(,R3) ROUND UP 07610000 SRL R3,1 NUMBER OF HALFWORDS 07620000 SR R6,R6 CLEAR CHECKSUM BUFFER 07630000 * 07640000 CKLOOP LH R7,0(,R2) GET NEXT HALFWORD 07650000 N R7,=X'0000FFFF' GET RID OF SIGN EXTENSION 07660000 AR R6,R7 ADD TO SUM 07670000 C R6,=X'00010000' TEST CARRY OUT OF HALFWORD 07680000 BC 4,CKL1 SKIP IF NO CARRY 07690000 LA R6,1(,R6) ADD IN CARRY 07700000 N R6,=X'0000FFFF' GET RID OF CARRY INDICATION 07710000 CKL1 LA R2,2(,R2) ADVANCE TO NEXT HALFWORD 07720000 BCT R3,CKLOOP LOOP TILL DONE 07730000 * 07740000 X R6,=X'0000FFFF' MAKE RESULT ONES COMPLEMENT 07750000 BR R14 RETURN 07760000 *---------------------------------------------------------------------* 07770000 * COMPLIMENTARY ROUTINES FOR BINARY TO CHARACTER CONVERSION * 07780000 * R1 CONTAINS POINTER TO STRING * 07790000 * R6 CONTAINS BINARY VALUE (HALFWORD) * 07800000 *---------------------------------------------------------------------* 07810000 BIN2ASC DS 0H 07820000 LR R9,R6 WE NEED 2 COPIES OF NUMBER 07830000 N R6,=X'0000F0F0' GET NIBBLES 0 & 2 07840000 SRL R6,4 MOVE TO LOW HALF OF BYTES 07850000 N R9,=X'00000F0F' GET NIBBLES 1 & 3 07860000 STCM R6,2,0(R1) STORE NIBBLES IN 4 BYTES 07870000 STCM R9,2,1(R1) 07880000 STCM R6,1,2(R1) 07890000 STCM R9,1,3(R1) 07900000 OC 0(4,R1),CHARSKEL MAKE THEM CHARACTERS 07910000 BR R14 RETURN. 07920000 * 07930000 ASC2BIN ICM R6,2,0(R1) 07940000 ICM R9,2,1(R1) 07950000 ICM R6,1,2(R1) 07960000 ICM R9,1,3(R1) 07970000 SLL R6,4 THESE GUYS ARE THE HIGH NIBBLES 07980000 N R6,=X'0000F0F0' ISOLATE THE INFORMATION WE WANT 07990000 N R9,=X'00000F0F' 08000000 OR R6,R9 NOW PUT ALL 4 NIBBLES TOGETHER 08010000 BR R14 08020000 EJECT 08030000 *---------------------------------------------------------------------* 08040000 * ENCAPSULATE FT3270 DATA PACKET INTO FT3270 XFER PACKET & SEND IT. * 08050000 * WAIT FOR REPLY BUFFER AND VERIFY ITS VALIDITY * 08060000 * ON ENTRY: R6 CONTAINS CHKSUM * 08070000 * R8 CONTAINS LENGTH OF DATA BUFFER * 08080000 * ON EXIT: R6 CONTAINS CHKSUM * 08090000 * R8 CONTAINS LENGTH OF DATA BUFFER (0 IF LENGTH ERROR) * 08100000 * SCRATCH: R1, R2 * 08110000 *---------------------------------------------------------------------* 08120000 SNDPKT DS 0H 08130000 ST R14,XSND14 08140000 * 08150000 LA R1,ZCHKSUM PUT CHKSUM IN XFER HEADER 08160000 BAL R14,BIN2ASC 08170000 LR R6,R8 08180000 LA R1,ZLENGTH PUT LENGTH IN XFER HEADER 08190000 BAL R14,BIN2ASC 08200000 * 08210000 MVC ZSNDBUFF+4(3),Z7171 FIX UP HEADER STRING 08220000 LA R2,ZBUFFER 08230000 AR R2,R8 POINT TO END OF DATA 08240000 MVI 0(R2),X'7F' PUT IN STRING TERMINATOR 08250000 * 08260000 A R8,=F'16' HEADER + LEN + CHKSUM + X'7F' 08270000 STH R8,ZSND+6 COMPLETE THE CCW 08280000 LA R0,ZSND POINT TO THE CCW AND 08290000 BAL R14,IOREQ GO WRITE IT. 08300000 BAL R14,IOWAIT WAIT FOR AN ATTENTION. 08310000 LA R0,ZRCV CCW FOR READ. 08320000 BAL R14,IOREQ GET THE BUFFER FROM THE PC. 08330000 CLI ZRCVBUFF,X'E8' THIS BYTE'S FOR 7171! 08340000 BNZ LOSTTN 08350000 * 08360000 LA R8,BUFFSIZE MAXIMUM INPUT BUFFER SIZE 08370000 SR R8,R1 RESIDUAL COUNT FROM CONSOLE READ 08380000 S R8,=F'12' HDR + LEN + CHKSUM + CR 08390000 BC 12,SP2 TOO SMALL A PACKET RETURNED 08400000 LA R1,ZLENGTH PROCESS LENGTH OF RETURNED PACKET 08410000 BAL R14,ASC2BIN 08420000 CR R6,R8 SEE IF LENGTHS AGREE 08430000 BZ SP1 08440000 SP2 SR R8,R8 BAD RETURN CODE 08450000 B SP3 08460000 * 08470000 SP1 LA R1,ZCHKSUM GET THE CHKSUM 08480000 BAL R14,ASC2BIN 08490000 SP3 L R14,XSND14 08500000 BR R14 RETURN. 08510000 EJECT 08520000 *---------------------------------------------------------------------* 08530000 * SUBROUTINE TO PERFORM 3270 FULL-SCREEN I/O. * 08540000 * THIS WAS COPIED FROM THE "SPAM" PROGRAM WRITTEN BY LARRY CHACE * 08550000 * R0 POINTS TO THE CHANNEL PROGRAM. * 08560000 * R1 RETURNS THE RESIDUAL COUNT. * 08570000 * (IN 1991, LARRY CHACE RETURNED TO MAKE THIS RUN IN XA-MODE.) XA 08580000 *---------------------------------------------------------------------* 08590000 IOREQ DS 0H 08600000 ST R14,IORSR14 SAVE OUR RETURN ADDRESS. XA 08610000 L R1,XTERMADD BE SURE THAT ANY 08620000 IOR010 BAL R14,TIOIT PREVIOUS OPERATION XA 08630000 BC 6,IOR010 HAS COMPLETED 08640000 BC 1,GONEAWAY CORRECTLY. 08650000 IOR020 DIAG R0,R1,X'58' START THE CHANNEL PROGRAM 08660000 BC 8,IOR030 AND CONTINUE IF STARTED. 08670000 BC 4,IOR040 CHECK FOR ANY STATUS BITS. 08680000 BC 2,IOR020 LOOP IF IT WAS BUSY. 08690000 BC 1,GONEAWAY QUIT IF CONSOLE IS GONE. 08700000 IOR030 BAL R14,TIOIT WAIT FOR THE 'SIO' XA 08710000 BC 2,IOR030 TO COMPLETE. 08720000 BC 1,GONEAWAY QUIT IF CONSOLE IS GONE. 08730000 IOR040 CLI IOX45,X'00' FOR CHANNEL ERRORS 08740000 BNE GONEAWAY WE CAN ONLY QUIT. 08750000 CLI IOX44,X'0C' IF IT COMPLETED NORMALLY, 08760000 BE IOR060 THEN WE ARE ALL DONE. 08770000 CLI IOX44,X'08' IF ONLY CHANNEL END, 08780000 BE IOR050 GO WAIT FOR DEVICE END. 08790000 CLI IOX44,X'8E' IF CP STOLE THE SCREEN, 08800000 BE GONEAWAY TAKE THE 'REPEAT' EXIT. 08810000 TM IOX44,X'B0' FOR ATTN, CUE, OR BUSY, 08820000 BNZ IOR020 RESTART THE DIAGNOSE. 08830000 TM IOX44,X'0C' IF NEITHER CE NOR DE, 08840000 BZ IOR020 THEN TRY IT ONCE AGAIN. 08850000 IOR050 BAL R14,TIOIT WAIT UNTIL DEVICE END XA 08860000 BC 2,IOR050 FINALLY COMES IN. 08870000 BC 1,GONEAWAY QUIT IF CONSOLE IS GONE. 08880000 IOR060 DS 0H 08890000 LH R1,IOX46 LOAD THE RESIDUAL COUNT. 08900000 L R14,IORSR14 RESTORE OUR RETURN ADDRESS. XA 08910000 LTR R14,R14 RETURN SUCCESSFULLY 08920000 BR R14 WITH CC = BNZ (BNE). 08930000 SPACE 1 XA 08940000 * XA 08950000 * ROUTINE TO PERFORM OR SIMULATE A "TEST I/O" INSTRUCTION. XA 08960000 * XA 08970000 * RETURN WITH: XA 08980000 * CC=0 MASK=8 FOR DEVICE AVAILABLE. XA 08990000 * CC=1 MASK=4 FOR CSW STORED. XA 09000000 * CC=2 MASK=2 FOR DEVICE BUSY. XA 09010000 * CC=3 MASK=1 FOR DEVICE VANISHED. XA 09020000 * XA 09030000 TIOIT DS 0H XA 09040000 TM NUCMFLAG,NUCMXA IF WE ARE IN XA MODE, XA 09050000 BO TIO010 THEN GO USE TSCH. XA 09060000 TIO 0(R1) FOR 370 MODE, DO THE TIO AND XA 09070000 MVC IOXCSW,X'44' GET THE CSW STUFF. XA 09080000 BR R14 RETURN WITH CC SET. XA 09090000 TIO010 DS 0H XA 09100000 ST R1,TIOSR1 SAVE THE DEVICE ADDRESS. XA 09110000 L R1,TIOSUBCH GET THE SUBCHANNEL NUMBER. XA 09120000 TSCH XAIRB FOR STATUS, GET IT. XA 09130000 BC 1,TIO090 QUIT IF IT DISAPPEARED. XA 09140000 BC 8,TIO080 GET ANY STORED STATUS. XA 09150000 MVC IOXCSW,TIOCSWOK FOR NO STATUS, FAKE THE CSW XA 09160000 CR R14,R14 AND RETURN CC=0 MASK=8. XA 09170000 B TIO090 XA 09180000 SPACE 1 XA 09190000 TIO080 DS 0H XA 09200000 MVC IOX44(4),XASCSW+8 GET THE STORED STATUS AND SET XA 09210000 TM *,X'FF' CC =1 MASK=4. XA 09220000 SPACE 1 XA 09230000 TIO090 DS 0H XA 09240000 L R1,TIOSR1 RESTORE THE DEVICE ADDRESS. XA 09250000 BR R14 RETURN HAPPILY. XA 09260000 SPACE 1 XA 09270000 TIOCSWOK DC X'0C000000' A FAKE GOOD CSW STATUS. XA 09280000 SPACE 2 XA 09290000 *---------------------------------------------------------------------* 09300000 * ROUTINE TO WAIT FOR THE I/O INTERRUPT. * 09310000 * XA 09320000 * THIS CAN USED ONLY FOR CONSOLE ATTENTION INTERRUPTS. XA 09330000 * XA 09340000 *---------------------------------------------------------------------* 09350000 IOWAIT DS 0H 09360000 ENABLE INTTYPE=CONSOLE XA 09370000 LPSW IOWPSW WAIT NOW FOR THE INTERRUPT. 09380000 IOWAKE BR R14 09390000 EJECT 09400000 *---------------------------------------------------------------------* 09410000 * THESE VARIABLES ARE USED THROUGHOUT THE PROGRAM * 09420000 *---------------------------------------------------------------------* 09430000 DS 0D XA 09440000 SAVEAREA DS 18F 09450000 SPACE 1 XA 09460000 *---------------------------------------------------------------------* 09470000 * DATA AREAS FOR I/O ROUTINES * 09480000 *---------------------------------------------------------------------* 09490000 XIONPSW DS D CMS'S I/O NEW PSW. 09500000 XEXNPSW DS D CMS'S EXT NEW PSW. 09510000 IOWPSW DC X'00020000',A(0) (THIS IS SET IN 'SETUP'.) XA 09520000 XTERMADD DS F TERMINAL ADDRESS. 09530000 SPACE 1 XA 09540000 SCHIB DS 0D,13F THE SUBCHANNEL INFO BLOCK. XA 09550000 ORG SCHIB+5 XA 09560000 SCHCTL DS X A FLAG BYTE: XA 09570000 SCHVLD EQU B'00000001' DEVICE NUMBER IS VALID. XA 09580000 ORG SCHIB+6 XA 09590000 SCHDEV DS H DEVICE NUMBER (ADDRESS). XA 09600000 ORG , (MORE RANDOM STUFF.) XA 09610000 IOXCSW DS 0F THE CSW SECOND HALF: XA 09620000 IOX44 DS X CSW (X'44'). XA 09630000 IOX45 DS X CSW (X'45'). XA 09640000 IOX46 DS H CSW (X'46'). XA 09650000 TIOSUBCH DS F THE CONSOLE'S SUBCHANNEL NUMBER. XA 09660000 XAIRB DS (0*16)F THE STANDARD IRB: XA 09670000 XASCSW DS 3F THE SUBCHAN STATUS WORD. XA 09680000 DS 13F (THE OTHER STUFF.) XA 09690000 SPACE 1 XA 09700000 *--------------------------------------------------------------------XA 09710000 * GENERAL REGISTER SAVE AREAS FOR SUBROUTINES. XA 09720000 *--------------------------------------------------------------------XA 09730000 XESTA14 DS F 'INIT' R14 SAVE AREA. XA 09740000 SHIP14 DS F 'SHIPDOWN' R14 SAVE AREA. XA 09750000 NEGO14 DS F 'UNNEGOT' R14 SAVE AREA. XA 09760000 XCENTRAL DS 15F 'CENTRAL' SAVE AREA. XA 09770000 CISR14 DS F 'COPYIN' R14 SAVE AREA. XA 09780000 COSR14 DS F 'COPYOUT' R14 SAVE AREA. XA 09790000 XSND14 DS F 'SNDPKT' R14 SAVE AREA. XA 09800000 IORSR14 DS F 'IOREQ' R14 SAVE AREA. XA 09810000 TIOSR1 DS F 'IOREQ' R1 SAVE AREA. XA 09820000 SPACE 1 XA 09830000 *--------------------------------------------------------------------XA 09840000 * GENERAL BUFFERS AND THINGS AND STUFF. XA 09850000 *--------------------------------------------------------------------XA 09860000 BUFFSIZE EQU 16*256-10 MAX SEND & RCV BUFFER SIZE 09870000 TNFTLEN EQU 2000 BUFFER SIZES FOR EACH PC PROGRAM 09880000 C19FTLEN EQU 150 09890000 FTLEN DS 1F DATA BLOCK SIZE TO DOWNLOAD 09900000 * 09910000 TBUFFER DS AL(4) POINTER TO TEMPORARY STAGING BUFFER 09920000 RETCODE DC F'0' SAVE THE RETURN CODE. 09930000 RETCMS DC F'0' SAVE THE RETURN CODE FROM CMS MACROS 09940000 DW64K DC A((64*1024)/8) SIZE OF CMS READ/WRITE BUFFER 09950000 DW16K DC A((16*1024)/8) SIZE OF FT3270 BUFFER 09960000 UNNFLAG DC X'0' FLAG TO PREVENT UNNEGOT LOOP 09970000 WRFLAG DC X'0' FLAG TO INDICATE LAST RECORD NOT PADDED. 09980000 C19FLAG DS 1C FLAG TO INDICATE RUNNING C19 ON PC. 09990000 NOSTRIP DC X'0' DO NOT PERFORM 8 FOR 7 CONVERSION. 10000000 ESCCHAR DC X'7E' THE ESCAPE CHARACTER! 10010000 HEXEOR DC X'0A' INDICATES END-OF-RECORD 10020000 CHARSKEL DC X'40404040' MAKE CHARACTERS FROM BINARY 10030000 * 10040000 COTABLEN EQU 5 10050000 COTABLE DC X'0211137FFF' TABLE OF DANGEROUS CHARACTERS 10060000 CITABLE DC X'02070D11137FFF' OUR TABLE OF REPLACEMENTS 10070000 SPACE 1 XA 10080000 *---------------------------------------------------------------------* 10090000 * COMMANDS TO SEND DIRECTLY TO CP VIA DIAGNOSE 8. * 10100000 *---------------------------------------------------------------------* 10110000 DS 0F 10120000 CPMSGOFF DC C'SET MSG OFF' 10130000 DC X'15' 10140000 DC C'SET WNG OFF' 10150000 DC X'15' 10160000 DC C'SET IMSG OFF' 10170000 CPOFFLEN EQU *-CPMSGOFF 10180000 * 10190000 CPMSGON DC C'SET MSG ON' 10200000 DC X'15' 10210000 DC C'SET WNG ON' 10220000 DC X'15' 10230000 DC C'SET IMSG ON' 10240000 CPONLEN EQU *-CPMSGON 10250000 EJECT 10260000 *---------------------------------------------------------------------* 10270000 * EBCDIC / ASCII TRANSLATION TABLES * 10280000 *---------------------------------------------------------------------* 10290000 DS 0D XA 10300000 EBCDTAB DC X'00010203372D2E2F1605250B0C0D0E0F' 10310000 DC X'101112133C3D322618193F271C1D1E1F' 10320000 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 10330000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 10340000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 10350000 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 10360000 DC X'79818283848586878889919293949596' 10370000 DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 10380000 * 10390000 DS 0D XA 10400000 ASCIITAB DC X'000102030009007F0000000B0C0D0E0F' 10410000 DC X'1011121300000800181900001C1D1E1F' 10420000 DC X'00000000000D171B0000000000050607' LC 10430000 DC X'0000160000000004000000001415001A' 10440000 DC X'200000000000000000005C2E3C282B7C' 10450000 DC X'2600000000000000000021242A293B5E' 10460000 DC X'2D2F00000000000000007C2C255F3E3F' 10470000 DC X'000000000000000000603A2340273D22' 10480000 DC X'00616263646566676869007B00000000' 10490000 DC X'006A6B6C6D6E6F707172007D00000000' 10500000 DC X'007E737475767778797A0000005B0000' 10510000 DC X'000000000000000000000000005D0000' 10520000 DC X'7B414243444546474849000000000000' 10530000 DC X'7D4A4B4C4D4E4F505152000000000000' 10540000 DC X'5C00535455565758595A000000000000' 10550000 DC X'303132333435363738397C0000000000' 10560000 EJECT 10570000 *---------------------------------------------------------------------* 10580000 * THESE VARIABLES ARE USED BY FTCMS AS WELL * 10590000 *---------------------------------------------------------------------* 10600000 FTCOMMON DS 0F 10610000 * 10620000 BYTELEFT DS 1F AVAILABLE SPACE ON SAME 10630000 NUMBYTES DS 1F SIZE OF FILE TO BE DOWNLOADED 10640000 XNOREC DS 1F NUMBER OF RECORDS TO DOWNLOAD 10650000 CLRECL DC X'0000FFFF' DEFAULT LENGTH FOR FIXED LENGTH UPLOAD 10660000 FSPECLEN DS 1F LENGTH OF NAME OF DOS FILESPEC 10670000 CRECFM DC F'0' RECFM FOR UPLOAD 10680000 BINTEXT DS CL(1) INDICATES WHETHER TO PERFORM CONVERSION 10690000 UPDOWN DS CL(1) WHETHER UPLOAD OR DOWNLOAD 10700000 NEGO DS 0F NEGOTIATION STRING 10710000 DC X'08' GRAPHICS ESCAPE, FOLLOWED BY 10720000 DS CL(1) THE PARTICULAR NEGOTIATION CODE, 10730000 DS CL(4) THE LENGTH IF DOWNLOAD, 10740000 DS CL(1) ANOTHER BYTE OF FLAG BITS, AND 10750000 DS CL(80) FOLLOWED BY ROOM FOR THE DOS FILE PATH. 10760000 SPACE 1 XA 10770000 *---------------------------------------------------------------------* 10780000 * LITERAL AREA * 10790000 *---------------------------------------------------------------------* 10800000 LTORG 10810000 EJECT 10820000 *---------------------------------------------------------------------* 10830000 * CCW'S MESSAGES, & BUFFERS * 10840000 *---------------------------------------------------------------------* 10850000 ZERASE CCW X'19',0,X'20',1 INITIAL WRITE TO 10860000 ORG ZERASE+5 CLEAR THE SCREEN 10870000 DC X'FF' (AVOID 'MORE'.) 10880000 ORG , 10890000 XESTAB DC X'1B1B' 10900000 DC X'14' OUR CURRENT VERSION NUMBER 10910000 DC C'NOT ACCEPTABLE WORKSTATION FOR FILE TRANSFER; PRESS' 10920000 DC C' ENTER TO RETURN. ' 10930000 VTABLE DC X'14FF0C0DFF' PC PROGRAM VERSIONS TO ACCEPT 10940000 * 10950000 ZSND CCW X'29',ZSNDBUFF,X'20',0 10960000 ORG ZSND+5 10970000 DC X'90' 10980000 ORG , 10990000 ZRCV CCW X'2A',ZRCVBUFF,X'20',BUFFSIZE 11000000 ORG ZRCV+5 11010000 DC X'80' 11020000 ORG , 11030000 Z7171 DC X'110001' REPLACE 3 BYTES OF ZSNDBUFF 11040000 DS 0F 11050000 * 11060000 ZSNDBUFF DC X'03115D7F110001' 7 BYTE HEADER FOR CP & 7171 11070000 ZRCVBUFF EQU ZSNDBUFF+4 7171 FILLS IN 3 BYTES. 11080000 ZLENGTH DS CL(4) LENGTH OF DATA 11090000 ZCHKSUM DS CL(4) CHECKSUM 11100000 ZBUFFER DS CL(BUFFSIZE) SEND & RECEIVE BUFFER 11110000 * 11120000 PRINT NOGEN 11130000 REGEQU 11140000 NUCON , XA 11150000 END FT3270 11160000